home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / c / error.c < prev    next >
C/C++ Source or Header  |  1987-06-04  |  14KB  |  712 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6.  
  7. /*
  8.  
  9.     error.c
  10.  
  11.     Errors
  12. */
  13.  
  14. #include "include.h"
  15.  
  16. object siSuniversal_error_handler;
  17.  
  18. static object null_string;
  19.  
  20. object siSterminal_interrupt;
  21.  
  22. terminal_interrupt(correctable)
  23. {
  24.     ifuncall1(siSterminal_interrupt, correctable?Ct:Cnil);
  25. }
  26.  
  27. object
  28. ihs_function_name(x)
  29. object x;
  30. {
  31.     object y;
  32.  
  33.     switch (type_of(x)) {
  34.     case t_symbol:
  35.         return(x);
  36.  
  37.     case t_cons:
  38.         y = x->c.c_car;
  39.         if (y == Slambda)
  40.             return(Slambda);
  41.         if (y == Slambda_closure)
  42.             return(Slambda_closure);
  43.         if (y == Slambda_block) {
  44.             x = x->c.c_cdr;
  45.             if (type_of(x) != t_cons)
  46.                 return(Slambda_block);
  47.             return(x->c.c_car);
  48.         }
  49.         if (y == Slambda_block_closure) {
  50.             x = x->c.c_cdr;
  51.             if (type_of(x) != t_cons)
  52.                 return(Slambda_block_closure);
  53.             x = x->c.c_cdr;
  54.             if (type_of(x) != t_cons)
  55.                 return(Slambda_block_closure);
  56.             x = x->c.c_cdr;
  57.             if (type_of(x) != t_cons)
  58.                 return(Slambda_block_closure);
  59.             x = x->c.c_cdr;
  60.             if (type_of(x) != t_cons)
  61.                 return(Slambda_block_closure);
  62.             return(x->c.c_car);
  63.         }
  64.         return(Cnil);
  65.  
  66.     case t_cfun:
  67.         return(x->cf.cf_name);
  68.  
  69.     case t_cclosure:
  70.         return(x->cc.cc_name);
  71.  
  72.     default:
  73.         return(Cnil);
  74.     }
  75. }
  76.  
  77. object
  78. ihs_top_function_name()
  79. {
  80.     object x;
  81.     ihs_ptr h = ihs_top;
  82.  
  83.     while (h >= ihs_org) {
  84.         x = ihs_function_name(h->ihs_function);
  85.         if (x != Cnil)
  86.             return(x);
  87.         h--;
  88.     }
  89.     return(Cnil);
  90. }
  91.  
  92.  
  93. call_error_handler()
  94. {
  95.     super_funcall(siSuniversal_error_handler);
  96. }
  97.  
  98.  
  99. FEerror(s, num, arg1, arg2, arg3, arg4)
  100. char *s;
  101. int num;
  102. object arg1, arg2, arg3, arg4;
  103. {
  104.     vs_base = vs_top;
  105.  
  106.     vs_push(Kerror);            /*  :ERROR  */
  107.     vs_push(Cnil);                /*  not correctable  */
  108.     vs_push(ihs_top_function_name());    /*  function  */
  109.     vs_push(null_string);            /*  continue-format-string  */
  110.     vs_push(Cnil);
  111.     if(num >= 1) vs_push(arg1);        /*  arguments  */
  112.     if(num >= 2) vs_push(arg2);
  113.     if(num >= 3) vs_push(arg3);
  114.     if(num >= 4) vs_push(arg4);
  115.     vs_base[4] = make_simple_string(s);    /*  error-format-string  */
  116.     call_error_handler();
  117. }
  118.  
  119. FEwrong_type_argument(type, value)
  120. object type, value;
  121. {
  122.     vs_base = vs_top;
  123.     vs_push(Kwrong_type_argument);
  124.     vs_push(Cnil);
  125.     vs_push(ihs_top_function_name());
  126.     vs_push(null_string);
  127.     vs_push(Cnil);
  128.     vs_push(value);
  129.     vs_push(type);
  130.     vs_base[4] = make_simple_string("~S is not of type ~S.");
  131.     call_error_handler();
  132. }
  133.  
  134. FEtoo_few_arguments(base, top)
  135. object *base, *top;
  136. {
  137.     vs_base = vs_top;
  138.     vs_push(Ktoo_few_arguments);
  139.     vs_push(Cnil);
  140.     vs_push(ihs_top_function_name());
  141.     vs_push(null_string);
  142.     vs_push(make_simple_string("~S requires more than ~R argument~:p."));
  143.     vs_push(ihs_top_function_name());
  144.     vs_push(make_fixnum(top - base));
  145.     call_error_handler();
  146. }
  147.  
  148. FEtoo_few_argumentsF(args)
  149. object args;
  150. {
  151.     vs_base = vs_top;
  152.     vs_push(Ktoo_few_arguments);
  153.     vs_push(Cnil);
  154.     vs_push(ihs_top_function_name());
  155.     vs_push(null_string);
  156.     vs_push(Cnil);
  157.     vs_push(ihs_top_function_name());
  158.     vs_push(args);
  159.     vs_base[4] = make_simple_string("Too few arguments.");
  160.     call_error_handler();
  161. }
  162.  
  163. FEtoo_many_arguments(base, top)
  164. object *base, *top;
  165. {
  166.     vs_base = vs_top;
  167.     vs_push(Ktoo_many_arguments);
  168.     vs_push(Cnil);
  169.     vs_push(ihs_top_function_name());
  170.     vs_push(null_string);
  171.     vs_push(make_simple_string("~S requires less than ~R argument~:p."));
  172.     vs_push(ihs_top_function_name());
  173.     vs_push(make_fixnum(top - base));
  174.     call_error_handler();
  175. }
  176.  
  177. FEtoo_many_argumentsF(args)
  178. object args;
  179. {
  180.     vs_base = vs_top;
  181.     vs_push(Ktoo_many_arguments);
  182.     vs_push(Cnil);
  183.     vs_push(ihs_top_function_name());
  184.     vs_push(null_string);
  185.     vs_push(Cnil);
  186.     vs_push(ihs_top_function_name());
  187.     vs_push(args);
  188.     vs_base[4] = make_simple_string("Too many arguments.");
  189.     call_error_handler();
  190. }
  191.  
  192. FEinvalid_macro_call()
  193. {
  194.     vs_base = vs_top;
  195.     vs_push(Kinvalid_form);
  196.     vs_push(Cnil);
  197.     vs_push(ihs_top_function_name());
  198.     vs_push(null_string);
  199.     vs_push(make_simple_string("Invalid macro call to ~S."));
  200.     vs_push(ihs_top_function_name());
  201.     call_error_handler();
  202. }
  203.  
  204. FEunexpected_keyword(key)
  205. object key;
  206. {
  207.     if (!keywordp(key))
  208.         not_a_keyword(key);
  209.     vs_base = vs_top;
  210.     vs_push(Kunexpected_keyword);
  211.     vs_push(Cnil);
  212.     vs_push(ihs_top_function_name());
  213.     vs_push(null_string);
  214.     vs_push(Cnil);
  215.     vs_push(ihs_top_function_name());
  216.     vs_push(key);
  217.     vs_base[4]
  218.     = make_simple_string("~S does not allow the keyword ~S.");
  219.     call_error_handler();
  220. }
  221.  
  222. FEinvalid_form(s, form)
  223. char *s;
  224. object form;
  225. {
  226.     vs_base = vs_top;
  227.     vs_push(Kinvalid_form);
  228.     vs_push(Cnil);
  229.     vs_push(ihs_top_function_name());
  230.     vs_push(null_string);
  231.     vs_push(Cnil);
  232.     vs_push(form);
  233.     vs_base[4] = make_simple_string(s);
  234.     call_error_handler();
  235. }
  236.  
  237. FEunbound_variable(sym)
  238. object sym;
  239. {
  240.     vs_base = vs_top;
  241.     vs_push(Kunbound_variable);
  242.     vs_push(Cnil);
  243.     vs_push(ihs_top_function_name());
  244.     vs_push(null_string);
  245.     vs_push(Cnil);
  246.     vs_push(sym);
  247.     vs_base[4] = make_simple_string("The variable ~S is unbound.");
  248.     call_error_handler();
  249. }
  250.  
  251. FEinvalid_variable(s, obj)
  252. char *s;
  253. object obj;
  254. {
  255.     vs_base = vs_top;
  256.     vs_push(Kinvalid_variable);
  257.     vs_push(Cnil);
  258.     vs_push(ihs_top_function_name());
  259.     vs_push(null_string);
  260.     vs_push(Cnil);
  261.     vs_push(obj);
  262.     vs_base[4] = make_simple_string(s);
  263.     call_error_handler();
  264. }
  265.  
  266. FEundefined_function(fname)
  267. object fname;
  268. {
  269.     vs_base = vs_top;
  270.     vs_push(Kundefined_function);
  271.     vs_push(Cnil);
  272.     vs_push(ihs_top_function_name());
  273.     vs_push(null_string);
  274.     vs_push(Cnil);
  275.     vs_push(fname);
  276.     vs_base[4] = make_simple_string("The function ~S is undefined.");
  277.     call_error_handler();
  278. }
  279.  
  280. FEinvalid_function(obj)
  281. object obj;
  282. {
  283.     vs_base = vs_top;
  284.     vs_push(Kinvalid_function);
  285.     vs_push(Cnil);
  286.     vs_push(ihs_top_function_name());
  287.     vs_push(null_string);
  288.     vs_push(Cnil);
  289.     vs_push(obj);
  290.     vs_base[4] = make_simple_string("~S is invalid as a function.");
  291.     call_error_handler();
  292. }
  293.  
  294.  
  295. CEerror(err_str, cont_str, num, arg1, arg2, arg3, arg4)
  296. char *err_str, *cont_str;
  297. int num;
  298. object arg1, arg2, arg3, arg4;
  299. {
  300.     object *old_base = vs_base;
  301.     object *old_top = vs_top;
  302.  
  303.     vs_base = vs_top;
  304.  
  305.     vs_push(Kerror);            /*  :ERROR  */
  306.     vs_push(Ct);                /*  correctable  */
  307.     vs_push(ihs_top_function_name());    /*  function  */
  308.     vs_push(make_simple_string(cont_str));
  309.                         /*  continue-format-string  */
  310.     vs_push(Cnil);
  311.     if(num >= 1) vs_push(arg1);        /*  arguments  */
  312.     if(num >= 2) vs_push(arg2);
  313.     if(num >= 3) vs_push(arg3);
  314.     if(num >= 4) vs_push(arg4);
  315.     vs_base[4] = make_simple_string(err_str);
  316.                         /*  error-format-string  */
  317.     call_error_handler();
  318.  
  319.     vs_top = old_top;
  320.     vs_base = old_base;
  321. }
  322.  
  323. /*
  324.     Lisp interface to IHS
  325. */
  326.  
  327. ihs_ptr get_ihs_ptr(x)
  328. object x;
  329. {
  330.     ihs_ptr p;
  331.  
  332.     if (type_of(x) != t_fixnum)
  333.         goto ILLEGAL;
  334.     p = ihs_org + fix(x);
  335.     if (ihs_org <= p && p <= ihs_top)
  336.         return(p);
  337. ILLEGAL:
  338.     FEerror("~S is an illegal ihs index.", 1, x);
  339. }
  340.  
  341. siLihs_top()
  342. {
  343.     check_arg(0);
  344.     vs_push(make_fixnum(ihs_top - ihs_org));
  345. }
  346.  
  347. siLihs_fun()
  348. {
  349.     check_arg(1);
  350.     vs_base[0] = get_ihs_ptr(vs_base[0])->ihs_function;
  351. }
  352.  
  353. siLihs_vs()
  354. {
  355.     check_arg(1);
  356.     vs_base[0] = make_fixnum(get_ihs_ptr(vs_base[0])->ihs_base - vs_org);
  357. }
  358.  
  359. frame_ptr get_frame_ptr(x)
  360. object(x);
  361. {
  362.     frame_ptr p;
  363.  
  364.     if (type_of(x) != t_fixnum)
  365.         goto ILLEGAL;
  366.     p = frs_org + fix(x);
  367.     if (frs_org <= p && p <= frs_top)
  368.         return(p);
  369. ILLEGAL:
  370.     FEerror("~S is an illegal frs index.", 1, x);
  371. }
  372.  
  373. siLfrs_top()
  374. {
  375.     check_arg(0);
  376.     vs_push(make_fixnum(frs_top - frs_org));
  377. }
  378.  
  379. siLfrs_vs()
  380. {
  381.     check_arg(1);
  382.     vs_base[0] = make_fixnum(get_frame_ptr(vs_base[0])->frs_lex - vs_org);
  383. }
  384.  
  385. siLfrs_bds()
  386. {
  387.     check_arg(1);
  388.     vs_base[0]
  389.     = make_fixnum(get_frame_ptr(vs_base[0])->frs_bds_top - bds_org);
  390. }
  391.  
  392. siLfrs_class()
  393. {
  394.     enum fr_class c;
  395.  
  396.     check_arg(1);
  397.  
  398.     c = get_frame_ptr(vs_base[0])->frs_class;
  399.     if (c == FRS_CATCH) vs_base[0] = Kcatch;
  400.     else if (c == FRS_PROTECT) vs_base[0] = Kprotect;
  401.     else if (c == FRS_CATCHALL) vs_base[0] = Kcatchall;
  402.     else FEerror("Unknown frs class was detected.", 0);
  403. }
  404.  
  405. siLfrs_tag()
  406. {
  407.     check_arg(1);
  408.     vs_base[0] = get_frame_ptr(vs_base[0])->frs_val;
  409. }
  410.  
  411. siLfrs_ihs()
  412. {
  413.     check_arg(1);
  414.     vs_base[0]
  415.     = make_fixnum(get_frame_ptr(vs_base[0])->frs_ihs - ihs_org);
  416. }
  417.  
  418. bds_ptr get_bds_ptr(x)
  419. object(x);
  420. {
  421.     bds_ptr p;
  422.  
  423.     if (type_of(x) != t_fixnum)
  424.         goto ILLEGAL;
  425.     p = bds_org + fix(x);
  426.     if (bds_org <= p && p <= bds_top)
  427.         return(p);
  428. ILLEGAL:
  429.     FEerror("~S is an illegal bds index.", 1, x);
  430. }
  431.  
  432. siLbds_top()
  433. {
  434.     check_arg(0);
  435.     vs_push(make_fixnum(bds_top - bds_org));
  436. }
  437.  
  438. siLbds_var()
  439. {
  440.     check_arg(1);
  441.     vs_base[0] = get_bds_ptr(vs_base[0])->bds_sym;
  442. }
  443.  
  444. siLbds_val()
  445. {
  446.     check_arg(1);
  447.     vs_base[0] = get_bds_ptr(vs_base[0])->bds_val;
  448. }
  449.  
  450. object *get_vs_ptr(x)
  451. object(x);
  452. {
  453.     object *p;
  454.  
  455.     if (type_of(x) != t_fixnum)
  456.         goto ILLEGAL;
  457.     p = vs_org + fix(x);
  458.     if (vs_org <= p && p < vs_top)
  459.         return(p);
  460. ILLEGAL:
  461.     FEerror("~S is an illegal vs index.", 1, x);
  462. }
  463.  
  464. siLvs_top()
  465. {
  466.     object x;
  467.     check_arg(0);
  468.     /* shouldn't ref vs_top in a vs_push */
  469.     x = (make_fixnum(vs_top - vs_org));
  470.     vs_push(x);
  471. }
  472.  
  473. siLvs()
  474. {
  475.     check_arg(1);
  476.     vs_base[0] = *get_vs_ptr(vs_base[0]);
  477. }
  478.  
  479. siLsch_frs_base ()
  480. {
  481.     frame_ptr x;
  482.     ihs_ptr y;
  483.  
  484.     check_arg(2);
  485.     y = get_ihs_ptr(vs_base[1]);
  486.     for (x = get_frame_ptr(vs_base[0]);
  487.          x <= frs_top && x->frs_ihs < y; 
  488.          x++);
  489.     if (x > frs_top) vs_base[0] = Cnil;
  490.     else vs_base[0] = make_fixnum(x - frs_org);
  491.     vs_top--;
  492. }
  493.  
  494. siLinternal_super_go()
  495. {
  496.     frame_ptr fr;
  497.  
  498.     check_arg(3);
  499.  
  500.     fr = frs_sch(vs_base[0]);
  501.     if (fr == NULL)
  502.         FEerror("The tag ~S is missing.", 1, vs_base[0]);
  503.     if (vs_base[2] == Cnil)
  504.         vs_base[0] = vs_base[1];
  505.     else
  506.         vs_base[0] = MMcons(vs_base[0], vs_base[1]);
  507.     vs_base++;
  508.     vs_top = vs_base;
  509.     unwind(fr,vs_base[-1]);
  510. }
  511.  
  512. siLuniversal_error_handler()
  513. {
  514.     int i;
  515.  
  516.     for (i = 0;  i < vs_base[4]->st.st_fillp;  i++)
  517.         putchar(vs_base[4]->st.st_self[i]);
  518.     printf("\nLisp initialization failed.\n");
  519.     exit(0);
  520. }
  521.  
  522. check_arg_failed(n)
  523. int n;
  524. {
  525.     object *base = vs_base, *top = vs_top;
  526.  
  527.     vs_base = vs_top;
  528.     if (top - base < n)
  529.         vs_push(Ktoo_few_arguments);
  530.     else
  531.         vs_push(Ktoo_many_arguments);
  532.     vs_push(Cnil);
  533.     vs_push(ihs_top_function_name());
  534.     vs_push(null_string);
  535.     if (top - base < n)
  536.         vs_push(make_simple_string("~S requires ~R argument~:p,~%\
  537. but only ~R ~:*~[were~;was~:;were~] supplied."));
  538.     else
  539.         vs_push(make_simple_string("~S requires only ~R argument~:p,~%\
  540. but ~R ~:*~[were~;was~:;were~] supplied."));
  541.     vs_push(ihs_top_function_name());
  542.     vs_push(make_fixnum(n));
  543.     vs_push(make_fixnum(top - base));
  544.     call_error_handler();
  545. }
  546.  
  547. too_few_arguments()
  548. {
  549.     FEtoo_few_arguments(vs_base, vs_top);
  550. }
  551.  
  552. too_many_arguments()
  553. {
  554.     FEtoo_many_arguments(vs_base, vs_top);
  555. }
  556.  
  557. ck_larg_at_least(n, x)
  558. int n; object x;
  559. {
  560.     for(; n > 0; n--, x = x->c.c_cdr)
  561.         if(endp(x))
  562.           FEerror("APPLY sended too few arguments to LAMBDA.", 0);
  563. }
  564.  
  565. ck_larg_exactly(n, x)
  566. int n; object x;
  567. {
  568.     for(; n > 0; n--, x = x->c.c_cdr)
  569.         if(endp(x))
  570.           FEerror("APPLY sended too few arguments to LAMBDA.", 0);
  571.     if(!endp(x)) FEerror("APPLY sended too many arguments to LAMBDA.", 0);
  572. }
  573.  
  574. invalid_macro_call()
  575. {
  576.     FEinvalid_macro_call();
  577. }
  578.  
  579. keyword_value_mismatch()
  580. {
  581.     FEerror("Keywords and values do not match.", 0);
  582. }
  583.  
  584. not_a_keyword(x)
  585. object x;
  586. {
  587.     FEerror("~S is not a keyword.", 1, x);
  588. }
  589.  
  590. unexpected_keyword(key)
  591. object key;
  592. {
  593.     FEunexpected_keyword(key);
  594. }
  595.  
  596. object
  597. wrong_type_argument(typ, obj)
  598. object typ, obj;
  599. {
  600.     FEwrong_type_argument(typ, obj);
  601.     /*  no return  */
  602. }
  603.  
  604. illegal_declare(form)
  605. {
  606.     FEinvalid_form("~S is an illegal declaration form.", form);
  607. }
  608.  
  609. not_a_symbol(obj)
  610. {
  611.     FEinvalid_variable("~S is not a symbol.", obj);
  612. }
  613.  
  614. not_a_variable(obj)
  615. {
  616.     FEinvalid_variable("~S is not a variable.", obj);
  617. }
  618.  
  619. illegal_index(x, i)
  620. object x, i;
  621. {
  622.     FEerror("~S is an illegal index to ~S.", 2, i, x);
  623. }
  624.  
  625.  
  626. Lerror()
  627. {
  628.     object *base = vs_base, *top = vs_top;
  629.  
  630.     if (top - base == 0)
  631.         too_few_arguments();
  632.     vs_base = vs_top;
  633.     vs_push(Kerror);
  634.     vs_push(Cnil);
  635.     vs_push(ihs_function_name((ihs_top - 1)->ihs_function));
  636.     vs_push(null_string);
  637.     while (base < top)
  638.         vs_push(*base++);
  639.     call_error_handler();
  640. }
  641.  
  642. Lcerror()
  643. {
  644.     object *base = vs_base, *top = vs_top;
  645.  
  646.     if (top - base < 2)
  647.         too_few_arguments();
  648.     vs_base = vs_top;
  649.     vs_push(Kerror);
  650.     vs_push(Ct);
  651.     vs_push(ihs_function_name((ihs_top - 1)->ihs_function));
  652.     while (base < top)
  653.         vs_push(*base++);
  654.     super_funcall(siSuniversal_error_handler);
  655.     vs_base = vs_top;
  656.     vs_push(Cnil);
  657. }
  658.  
  659.  
  660. init_error()
  661. {
  662.     make_function("ERROR", Lerror);
  663.     make_function("CERROR", Lcerror);
  664.  
  665.     Kerror = make_keyword("ERROR");
  666.     Kwrong_type_argument = make_keyword("WRONG-TYPE-ARGUMENT");
  667.     Ktoo_few_arguments = make_keyword("TOO-FEW-ARGUMENTS");
  668.     Ktoo_many_arguments = make_keyword("TOO-MANY-ARGUMENTS");
  669.     Kunexpected_keyword = make_keyword("UNEXPECTED-KEYWORD");
  670.     Kinvalid_form = make_keyword("INVALID-FORM");
  671.     Kunbound_variable = make_keyword("UNBOUND-VARIABLE");
  672.     Kinvalid_variable = make_keyword("INVALID-VARIABLE");
  673.     Kundefined_function = make_keyword("UNDEFINED-FUNCTION");
  674.     Kinvalid_function = make_keyword("INVALID-FUNCTION");
  675.  
  676.     make_si_function("IHS-TOP", siLihs_top);
  677.     make_si_function("IHS-FUN", siLihs_fun);
  678.     make_si_function("IHS-VS", siLihs_vs);
  679.  
  680.     Kcatch = make_keyword("CATCH");
  681.     Kprotect = make_keyword("PROTECT");
  682.     Kcatchall = make_keyword("CATCHALL");
  683.  
  684.     make_si_function("FRS-TOP", siLfrs_top);
  685.     make_si_function("FRS-VS", siLfrs_vs);
  686.     make_si_function("FRS-BDS", siLfrs_bds);
  687.     make_si_function("FRS-CLASS", siLfrs_class);
  688.     make_si_function("FRS-TAG", siLfrs_tag);
  689.     make_si_function("FRS-IHS", siLfrs_ihs);
  690.  
  691.     make_si_function("BDS-TOP", siLbds_top);
  692.     make_si_function("BDS-VAR", siLbds_var);
  693.     make_si_function("BDS-VAL", siLbds_val);
  694.  
  695.     make_si_function("VS-TOP", siLvs_top);
  696.     make_si_function("VS", siLvs);
  697.  
  698.     make_si_function("SCH-FRS-BASE", siLsch_frs_base);
  699.  
  700.     make_si_function("INTERNAL-SUPER-GO", siLinternal_super_go);
  701.  
  702.     siSuniversal_error_handler =
  703.     make_si_function("UNIVERSAL-ERROR-HANDLER",
  704.              siLuniversal_error_handler);
  705.  
  706.     null_string = make_simple_string("");
  707.     enter_mark_origin(&null_string);
  708.  
  709.     siSterminal_interrupt = make_si_ordinary("TERMINAL-INTERRUPT");
  710.     enter_mark_origin(&siSterminal_interrupt);
  711. }
  712.